Imports System.Math

Public Class FGalaxyForm1
    Public xstr(40), xend(40), ystr(40), yend(40)
    Const pictdim% = 40                    ' maximum picture number  - array size
    Const Maxpixels = 2000
    Public kl(2, 30), rgbx(2)                      ' GETcoulour1
    Public xmax, ymax, xchrmax, ychrmax, lfn
    Public xcenter, ycenter
    Public colour As Long
    Public xp1, yp1, xp2, yp2                     ' Form1 top_left  bottom_right
    Public picture As Integer                     ' current picture number
    Public picture1, picture0 As Integer          ' current picture number
    Public countmax
    Public Amplification_old, Amplification
    Public swidth, sheight
    Public width1, height1
    Public pos, ipnt
    Public var(4) As Long
    Public blank, testblank
    Public dirname, filenm, flname As String
    Public state
    Public buffersize As Integer
    Public inputfile

    Public Const trace = 0
    Const posmax = 50

    Private Sub ButtonStart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ButtonStart.Click

        Dim ip As Integer

        GETScreen()
        Debug.Print("Command Start Height" + Str(Me.Height) + "Width" + Str(Me.Width))
        ip = Val(Me.TBpicture.Text)
        picture1 = ip
        Debug.Print("Command Start" + Str(ymax) + "Width" + Str(xmax))
        Main()

    End Sub

    Private Sub ButtonEnd_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ButtonEnd.Click

        End

    End Sub

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load

        FGalaxyForm2.Visible = True
        xstr(0) = -3 : xend(0) = 2 : ystr(0) = -2.5 : yend(0) = 2.5
        xstr(0) = -2.8 : xend(0) = 1.8 : ystr(0) = -2.3 : yend(0) = 2.3
        xp1 = 0 : xp2 = 1
        yp1 = 0 : yp2 = 1
        Amplification = 1
        Amplification_old = 1
        Me.TBpicture.Text = 0            ' Picture nr
        Me.TBxp1.Text = xp1          ' x1 %
        Me.TByp1.Text = yp1          ' y1 %
        Me.TBxp2.Text = xp2          ' x2 %
        Me.TByp2.Text = yp2          ' y2 %
        Me.TBamplification.Text = Amplification
        state = 0

        INITIALISE()

    End Sub

    Public Sub Main()



        ' DECLARE SUB VOLUME (stype%)
        '                       FGALAXY.BAS
        '       Revision 1.0    Original                          22 JAN 1995
        '       Revision 2.0    Added ' Screen update time        16 OKT 2001
        '       Revision 3.0    Visual Basic                      June 2012

        ' Create pictures
        '

        Dim ystart%                                ' new display 0 = yes <>0 y value
        Dim Title$
        Dim stpp As Integer
        Dim Ampl As Double
        Dim dx1, dy1 As Double                       ' Main
        Dim lx, ly As Double
        Dim dx, dy, xstr1, ystr1, xend1, yend1 As Double
        Dim x0, y0, a1, kleur, power, F1, Fn As Double
        Dim ystr0, yend0 As Double
        Dim xx, yy, cx, cy, cxx, cyy, cp As Double
        Dim countt As Integer
        Dim argbcolor As Color
        ' Dim patt As String

        ''Const ESC = 27, ENTER = 13
        ''Const UP = 72, DOWN = 80, LEFT = 75, RIGHT = 77

        Title$ = "Fractal Galaxies Demonstration"
        buffersize = 2

        ' ***************

        If picture1 >= pictdim% Then picture1 = pictdim%

        GETScreen()

        ' Debug.Print picture1; pictdim%

        ' If sheight > 1000 Then Form2.PictureBox1.Height = 1000
        sheight = FGalaxyForm2.PictureBox1.Height : swidth = FGalaxyForm2.PictureBox1.Width
        If trace = 1 Then Debug.Print(Text)
        Text = "Main Height" + Str(sheight) + " Width" + Str(swidth)
        If trace = 1 Then Debug.Print(Text)
        Text = "Main  stpp" + Str(stpp) + " ymax" + Str(ymax) + " ystr" + Str(ystart%) + " xmax" + Str(xmax) + " picture" + Str(picture1)
        Debug.Print(Text)

        '  Form2.Clear()   ***

        Dim bmp As New Bitmap(Maxpixels, Maxpixels)
        ' ReDim bmp(xmax, ymax)
a4:

        Ampl = Val(Me.TBamplification.Text)
        If Ampl <> Amplification Or (xp1 <> 0 And xp2 = 1 And FGalaxyForm2.WindowState = 0) Then
            ' If Ampl <> Amplification Then
            Text = "Main Amplification" + Str(Amplification) + " Ampl" + Str(Ampl) + " xp1" + Str(xp1) + " xp2" + Str(xp2)
            Debug.Print(Text)
            If xp1 = 0 Then
                dx1 = xend(1) - xstr(1) : dy1 = yend(1) - ystr(1)
                xcenter = (xend(picture1) + xstr(picture1)) / 2
                ycenter = (yend(picture1) + ystr(picture1)) / 2
                If Ampl > Amplification Then picture1 = picture1 + 1
                Me.TBpicture.Text = picture1               ' Picture nr
                picture0 = picture1                     ' save to test change
                xstr(picture1) = xcenter - dx1 / 2 / Ampl
                xend(picture1) = xcenter + dx1 / 2 / Ampl
                ystr(picture1) = ycenter - dy1 / 2 / Ampl
                yend(picture1) = ycenter + dy1 / 2 / Ampl
            Else
                lx = xend(picture1) - xstr(picture1) : ly = yend(picture1) - ystr(picture1)
                xp2 = 1 : yp2 = 1         ' one modification
                xcenter = xstr(picture1) + xp1 / xp2 * lx
                ycenter = ystr(picture1) + yp1 / yp2 * ly
                dx1 = xend(1) - xstr(1) : dy1 = yend(1) - ystr(1)
                If Ampl > Amplification Then picture1 = picture1 + 1
                xstr(picture1) = xcenter - dx1 / 2 / Ampl
                xend(picture1) = xcenter + dx1 / 2 / Ampl
                ystr(picture1) = ycenter - dy1 / 2 / Ampl
                yend(picture1) = ycenter + dy1 / 2 / Ampl
                xp1 = 0 : xp2 = 1
                yp1 = 0 : yp2 = 1
                Me.TBpicture.Text = picture1     ' Picture nr
                picture0 = picture1           ' save to test change
                Me.TBxp1.Text = xp1          ' x1 %
                Me.TByp1.Text = yp1          ' y1 %
                Me.TBxp2.Text = xp2          ' x2 %
                Me.TByp2.Text = yp2          ' y2 %
            End If
        Else
            SETSTANDARD()                            'set standard demo parameters.
        End If

        state = 0

        xstr1 = xstr(picture1) : xend1 = xend(picture1) : ystr1 = ystr(picture1) : yend1 = yend(picture1)
        dx = (xend1 - xstr1) / xmax : dy = (yend1 - ystr1) / ymax
        x0 = -0.7 : y0 = 0.27 : a1 = 0.9 : kleur = 0

        power = 10 ^ 10
        Text = "Main dx" + Str(Int(dx * power) / power) + " dy" + Str(Int(dy * power) / power) + " xstr1" + Str(Int(xstr1 * power) / power) + " xend1" + Str(Int(xend1 * power) / power) + " ystr1" + Str(Int(ystr1 * power) / power) + " yend1" + Str(Int(yend1 * power) / power)
        Debug.Print(Text)
        Me.TBxcenter.Text = Int(xcenter * power) / power
        ' Form1.Text1(7).Text = Int(xend1 * power) / power
        Me.TBycenter.Text = Int(ycenter * power) / power
        ' Form1.Text1(9).Text = Int(yend1 * power) / power
        F1 = (xend(1) - xstr(1)) * (yend(1) - ystr(1))
        Fn = (xend(picture1) - xstr(picture1)) * (yend(picture1) - ystr(picture1))
        Amplification_old = Amplification
        Amplification = F1 / Fn
        Amplification = Int(Sqrt(Amplification) + 0.5)
        Me.TBamplification.Text = Amplification

        BinaryFile_Init()

        ystr0 = 0 : yend0 = ymax - 1 : stpp = 1
        If filenm <> "" Then ystr0 = ymax - 1 : yend0 = 0 : stpp = -1 ' bottom up



        For Y% = ystr0 To yend0 Step stpp
            ' For Y% = 0 To ymax - 1 Step stpp
            ' DoEvents()
            Application.DoEvents()
            testblank = 0
            Me.TBcmax2.Text = Str(Y%)
            ' Debug.Print(Str(Y%))
            For X% = 0 To xmax - 1 Step 1
                If X% = xmax - 1 Then testblank = 1 ' write blank
                xx = xstr1 + X% * dx
                yy = ystr1 + Y% * dy
                cx = xx : cy = yy
                countt = 0
                Do
                    countt = countt + 1
                    cxx = cx * cx * (1 - a1 * cy) - cy * cy * (1 - a1 * cx) + x0
                    cyy = 2 * cy * cx + y0
                    cx = cxx : cy = cyy
                    cp = cx * cx + cy * cy
                Loop Until cp >= 20 Or countt > 3500

                GetArgbcolor(countt, argbcolor)
                If countt > countmax Then countmax = countt

                bmp.SetPixel(X%, Y%, argbcolor)

                If filenm <> "" Then BinaryFile()

            Next X%
            FGalaxyForm2.PictureBox1.Image = bmp
            Me.TBcmax1.Text = countmax

        Next Y%

        If filenm = "" Then Exit Sub

        Debug.Print("Main pos" + Str(pos))
        inputfile.Close()

        Exit Sub



    End Sub




    Sub GETScreen()
        '                                                                 ' GET' Screen
        Dim mmax As Integer

        xmax = Val(FGalaxyForm2.PictureBox1.Width)
        ymax = Val(FGalaxyForm2.PictureBox1.Height)
        mmax = Val(Me.TBsize.Text)     'Target

        If FGalaxyForm2.WindowState = 0 Then

            If xmax <> mmax Or ymax <> mmax Then
                ' Height    0    510     Width    0  120
                ' Height  200   3510     Width  200 3120
                ' Height  300   5010     Width  300 4620
                ' Height  500   8010     Width  500 7620
                Debug.Print("GETscreen" + Str(mmax))
                FGalaxyForm2.PictureBox1.Width = mmax : xmax = mmax
                FGalaxyForm2.PictureBox1.Height = mmax : ymax = mmax
                FGalaxyForm2.Width = mmax + 18
                FGalaxyForm2.Height = mmax + 40
                FGalaxyForm2.Visible = False
                Application.DoEvents()
                FGalaxyForm2.Visible = True
            End If

        End If


    End Sub

    Sub INITIALISE()
        '                                                               INITIALISE

        picture0 = 0                        ' picture number (initial )
        picture1 = picture0                 ' picture number

        ' Initialise subroutine GetArgbcolor

        kl(0, 0) = 0 : kl(1, 0) = 0 : kl(2, 0) = 0         ' white
        kl(0, 1) = 1 : kl(1, 1) = 0.5 : kl(2, 1) = 0.5
        kl(0, 2) = 0 : kl(1, 2) = 1 : kl(2, 2) = 1
        kl(0, 3) = 0.5 : kl(1, 3) = 0 : kl(2, 3) = 0.5
        kl(0, 4) = 1 : kl(1, 4) = 1 : kl(2, 4) = 0
        kl(0, 5) = 0 : kl(1, 5) = 0.5 : kl(2, 5) = 0.5
        kl(0, 6) = 1 : kl(1, 6) = 0 : kl(2, 6) = 1
        kl(0, 7) = 0.5 : kl(1, 7) = 1 : kl(2, 7) = 0.5
        kl(0, 8) = 1 : kl(1, 8) = 0 : kl(2, 8) = 0
        kl(0, 9) = 0.5 : kl(1, 9) = 0.5 : kl(2, 9) = 1
        kl(0, 10) = 0 : kl(1, 10) = 1 : kl(2, 10) = 0
        kl(0, 11) = 1 : kl(1, 11) = 0.5 : kl(2, 11) = 0.5
        kl(0, 12) = 0 : kl(1, 12) = 0 : kl(2, 12) = 1
        kl(0, 13) = 0.5 : kl(1, 13) = 0.5 : kl(2, 13) = 0
        kl(0, 14) = 1 : kl(1, 14) = 1 : kl(2, 14) = 1       ' black
        kl(0, 15) = 0 : kl(1, 15) = 0 : kl(2, 15) = 0       ' white
        kl(0, 16) = 1 : kl(1, 16) = 0.5 : kl(2, 16) = 0.5
        kl(0, 17) = 0 : kl(1, 17) = 1 : kl(2, 17) = 1
        kl(0, 18) = 0.5 : kl(1, 18) = 0 : kl(2, 18) = 0.5
        kl(0, 19) = 1 : kl(1, 19) = 1 : kl(2, 19) = 0
        kl(0, 20) = 0 : kl(1, 20) = 0.5 : kl(2, 20) = 0.5
        kl(0, 21) = 1 : kl(1, 21) = 0 : kl(2, 21) = 1
        kl(0, 22) = 0.5 : kl(1, 22) = 1 : kl(2, 22) = 0.5
        kl(0, 23) = 1 : kl(1, 23) = 0 : kl(2, 23) = 0
        kl(0, 24) = 0.5 : kl(1, 24) = 0.5 : kl(2, 24) = 1
        kl(0, 25) = 0 : kl(1, 25) = 1 : kl(2, 25) = 0
        kl(0, 26) = 1 : kl(1, 26) = 0.5 : kl(2, 26) = 0.5
        kl(0, 27) = 0 : kl(1, 27) = 0 : kl(2, 27) = 1
        kl(0, 28) = 0.5 : kl(1, 28) = 0.5 : kl(2, 28) = 0
        kl(0, 29) = 1 : kl(1, 29) = 1 : kl(2, 29) = 1       ' black

        GETScreen()

    End Sub



    Sub SETSTANDARD()
        '                                                               SETSTANDARD
        Dim power As Long
        Dim lx, ly, lx1, ly1, l1, l2 As Double

        power = 10 ^ 7
        ' Test that both coordinates are modified
        If xp2 = 1 Then xp1 = 0 : yp1 = 0
        If picture1 <> picture0 Then xp1 = 0 : yp1 = 0 : xp2 = 1 : yp2 = 1
        lx = xend(picture1) - xstr(picture1) : ly = yend(picture1) - ystr(picture1)
        lx1 = xp2 - xp1 : ly1 = yp2 - yp1
        l2 = lx1 * ly1 : l1 = Sqrt(l2)

        xend(picture1 + 1) = xstr(picture1) + lx * xp2
        xstr(picture1 + 1) = xstr(picture1) + lx * xp1
        yend(picture1 + 1) = ystr(picture1) + ly * yp2
        ystr(picture1 + 1) = ystr(picture1) + ly * yp1
        Text = "SETSTANDARD" + Str(picture1) + "xp1" + Str(Int(xp1 * power) / power) + "xp2" + Str(Int(xp2 * power) / power) + "yp1" + Str(Int(yp1 * power) / power) + "yp2" + Str(Int(yp2 * power) / power) + "lx*ly" + Str(Int(l1 * power) / power)
        If trace = 1 Then Debug.Print(Text)
        If (xp1 <> 0 Or picture1 = 0) And l1 > 0.01 Then picture1 = picture1 + 1
        xp1 = 0 : xp2 = 1
        yp1 = 0 : yp2 = 1
        Me.TBpicture.Text = picture1     ' Picture nr
        picture0 = picture1           ' save to test change
        Me.TBxp1.Text = xp1          ' x1 %
        Me.TByp1.Text = yp1          ' y1 %
        Me.TBxp2.Text = xp2          ' x2 %
        Me.TByp2.Text = yp2          ' y2 %

        Square(xstr(picture1), xend(picture1), ystr(picture1), yend(picture1))

        Text = "SETSTANDARD" + Str(picture1) + Str(Int(xstr(picture1) * power) / power) + Str(Int(xend(picture1) * power) / power) + Str(Int(ystr(picture1) * power) / power) + Str(Int(yend(picture1) * power) / power) + "lx*ly" + Str(Int(l1 * power) / power)
        If trace = 1 Then Debug.Print(Text)

    End Sub


 
    Public Sub GetArgbcolor(ByVal ip As Integer, ByRef argbcolor As Color)

        Dim jmax, n, ns, i As Integer
        Dim expp, j, ip1 As Double
        Dim deltakl As Double
        Dim rgbx(2) As Integer                   ' GETcoulour1
        Dim alpha, red, green, blue As Single

        jmax = 5
        n = 1
        ns = 50
        ' Form2.DrawWidth = n
        ip1 = ip - 1
        expp = Exp(-ip1 / 280)
        ip1 = ip1 * expp
        j = ip1 / jmax
        i = Int(j)
        j = j - i
        If i > 28 Then i = 29 : j = 1
        For ikl = 0 To 2
            deltakl = kl(ikl, i + 1) - kl(ikl, i)
            rgbx(ikl) = kl(ikl, i) * 255 + Int(deltakl * 255 * j)
        Next ikl

        ' Debug.Print("GetArgbcolor ip" + Str(ip) + " ip1" + Str(Int(ip1 * 100) / 100) + " i" + Str(i) + " j" + Str(Int(j * 100) / 100))
        ' red = 255: green = 0: blue = 0
        ' rgbx(0) = red: rgbx(1) = green: rgbx(2) = blue
        ' colour = RGB(rgbx(0), rgbx(1), rgbx(2))     ' red green blue
        red = rgbx(0) : green = rgbx(1) : blue = rgbx(2) : alpha = 255
        argbcolor = Color.FromArgb(alpha, red, green, blue)


    End Sub


    Public Sub Square(ByRef xp1, ByRef xp2, ByRef yp1, ByRef yp2)

        Dim X1, X2, Y1, Y2, area, lx, ly As Double
        Dim dx, dy As Double

        ' Debug.Print "Square"; xp1; "xp2"; xp2; "yp1"; yp1; "yp2"; yp2
        ' adjust the coordinates to square
        X1 = xp1 : X2 = xp2 : Y1 = yp1 : Y2 = yp2
        dx = X2 - X1 : dy = Y2 - Y1
        area = dx * dy
        lx = Sqrt(area * swidth / sheight) : ly = area / lx
        xcenter = (X1 + X2) / 2 : ycenter = (Y1 + Y2) / 2
        xp1 = xcenter - lx / 2 : xp2 = xcenter + lx / 2
        yp1 = ycenter - ly / 2 : yp2 = ycenter + ly / 2
        ' Debug.Print X, Y, l
        Debug.Print("Square " + Str(xp1) + "xp2" + Str(xp2) + "yp1" + Str(yp1) + "yp2" + Str(yp2) + Str(swidth) + Str(sheight))

    End Sub

    Public Sub BinaryFile_Init()

        Dim hdr(13) As Long
        Dim area As Double
        Dim patt As String
        Dim Numberofrecords As Long
        Dim width2 As Integer
        Dim lheader = 26
        Dim bytes = New Byte(buffersize - 1) {}

        width1 = swidth
        height1 = sheight
        filenm = LTrim$(Me.TBfilename.Text)
        dirname = LTrim$(Me.TBdirname.Text)
        ' C:\Users\Gebruiker\Documents\Visual Studio 2010\Projects\VB2010 FGalaxy\VB2010 FGalaxy\bin\Debug
        If filenm = "" Then Exit Sub
        filenm = dirname + filenm
        filenm = filenm + "." + LTrim$(Str(width1)) + "." + LTrim$(Str(Amplification))
        filenm = filenm + ".X" + LTrim$(Str(xcenter)) + ".Y" + LTrim$(Str(ycenter)) + ".BMP"

        Dim file As System.IO.FileStream
        file = System.IO.File.Create(filenm)
        file.Close()

        Application.DoEvents()

        inputfile = IO.File.Open(filenm, IO.FileMode.Open)
        Numberofrecords = 0       '   LOF(1)  ***
        Debug.Print(filenm + " Numberofrecords" + Str(Numberofrecords))
        hdr(1) = Asc("M") * 256 + Asc("B")
        width2 = width1

        blank = width1 Mod 4
        area = (width1 * 3 + blank) * height1 + lheader
        hdr(2) = area
        hdr(3) = 0
        Debug.Print("BinaryFile_Init width1" + Str(width1) + Str(height1) + Str(area))
        If area > 2 ^ 16 Then
            hdr(3) = Int(area / 2 ^ 16)
            hdr(2) = area - hdr(3) * 2 ^ 16
        End If
        hdr(6) = lheader
        hdr(8) = 12
        hdr(10) = width1
        hdr(11) = height1
        hdr(12) = 1
        hdr(13) = 16 + 8
        pos = 1
        patt = ""
        For i = 1 To 13
            bytes(0) = hdr(i) Mod 256
            bytes(1) = Int(hdr(i) / 256)
            inputFile.Write(bytes, 0, buffersize)
            Hex(hdr(i), patt)
            If trace = 1 Then Debug.Print("BinaryFile_Init " + Str(pos) + Str(hdr(i)) + patt)
            pos = pos + 2
        Next i
        ipnt = 0

    End Sub

    Public Sub BinaryFile()

        Dim in1 As Long
        Dim in2 As Integer
        Dim rgb1(3) As Long
        Dim patt As String
        Dim bytes = New Byte(buffersize - 1) {}

        ''red = 0: green = 8 * 16: blue = 8 * 16
        ''red = 15 * 16: green = 0: blue = 0            ' red  0000FF
        ''red = 15 * 16: green = 8 * 16: blue = 0       ' orange  0000FF
        ''rgb1(0) = blue: rgb1(1) = green: rgb1(2) = red: rgb1(3) = blue
        rgb1(0) = rgbx(2) : rgb1(1) = rgbx(1) : rgb1(2) = rgbx(0)
        rgb1(3) = rgb1(0)
        var(ipnt) = rgb1(0)
        var(ipnt + 1) = rgb1(1)
        var(ipnt + 2) = rgb1(2)

        bytes(0) = var(0)
        bytes(1) = var(1)

        inputfile.Write(bytes, 0, buffersize)

        If pos < posmax And trace = 1 Then
            patt = ""
            Hex(in2, patt)
            Debug.Print("BinaryFile pos " + Str(pos) + Str(in2) + patt)
        End If
        pos = pos + 2
        ipnt = ipnt + 1
        var(0) = var(2)
        var(1) = var(3)
        If ipnt = 2 Or (testblank = 1 And blank Mod 2 = 1) Then
            in1 = var(1) * 256 + var(0)  ' long
            in2 = in1

            bytes(0) = in2 Mod 256
            bytes(1) = Int(in2 / 256)
            inputfile.Write(bytes, 0, buffersize)

            patt = ""
            If pos < posmax And trace = 1 Then
                Hex(in2, patt)
                Debug.Print("BinaryFile pos " + Str(pos) + Str(in2) + patt)
            End If
            pos = pos + 2
            ipnt = 0
        End If
        If testblank = 1 And blank >= 2 Then
            bytes(0) = 0
            bytes(1) = 0
            inputfile.Write(bytes, 0, buffersize)
            pos = pos + 2
        End If

    End Sub


    Public Sub Hex(ByVal in1 As Long, ByRef a$)
        Dim a1(8)
        Dim signx, in2 As Integer
        Dim r, chr1 As String
        in2 = in1
        signx = 0
        If in2 < 0 Then in2 = 2 ^ 31 + in1 : signx = 1
        r = "" : chr1 = ""                      ' ** 611
        For i = 0 To 8
            a1(i) = in2 Mod 16
            in2 = Int(in2 / 16)
            If i = 7 And signx = 1 Then a1(i) = a1(i) + 8
            If a1(i) < 10 Then
                chr1 = Chr(Asc("0") + a1(i))  ' ***
            Else
                chr1 = Chr(Asc("A") + a1(i) - 10) '  ***
            End If
            r = chr1 + r
            ' Debug.Print i; in2; a1(i); chr1; r
        Next i
        a$ = r

        ' Debug.Print("Hex " + a$)

    End Sub



End Class